home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / arith.c < prev    next >
C/C++ Source or Header  |  1992-07-22  |  40KB  |  1,530 lines
  1. /* ******************************************************************** */
  2. /*  arith.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  arithmetic                                                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: arith.c,v 1.5 1992/05/28 11:19:01 pab Exp $
  9.  *
  10.  * $Log: arith.c,v $
  11.  * Revision 1.5  1992/05/28  11:19:01  pab
  12.  * fix
  13.  *
  14.  * Revision 1.5  1992/01/09  19:10:38  pab
  15.  * Fixed for low tagged ints
  16.  *
  17.  * Revision 1.4  1991/12/22  15:13:47  pab
  18.  * Xmas revision
  19.  *
  20.  * Revision 1.3  1991/09/22  19:14:32  pab
  21.  * Fixed obvious bugs
  22.  *
  23.  * Revision 1.2  1991/09/11  11:59:29  pab
  24.  * 11/9/91 First Alpha release of modified system
  25.  *
  26.  * Revision 1.1  1991/08/12  16:49:24  pab
  27.  * Initial revision
  28.  *
  29.  * Revision 1.19  1991/03/05  19:49:29  pab
  30.  * added sqrt function
  31.  *
  32.  * Revision 1.18  1991/02/13  18:15:15  kjp
  33.  * Somethign good + RCS log headers.
  34.  *
  35.  */
  36.  
  37. /*
  38.  * Change Log:
  39.  *   Version 1, May 1989
  40.  */
  41.  
  42. #include "defs.h"
  43. #include "structs.h"
  44. #include "error.h"
  45. #include "funcalls.h"
  46.  
  47. #include "global.h"
  48. #include <math.h>
  49.  
  50. extern int abs(int);
  51.  
  52. #include "ngenerics.h"
  53. #include "modboot.h"
  54.  
  55. EUFUN_1( Fn_numberp, a)
  56. {
  57.   return (typeof(a)>=TYPE_INT && typeof(a)<=TYPE_LASTNUMBER ? lisptrue : nil);
  58. }
  59. EUFUN_CLOSE
  60.  
  61. LispObject lift_number(LispObject *stackbase, int newtype)
  62. {
  63.   LispObject a = ARG_0(stackbase);
  64.   switch(typeof(a)) 
  65.     {
  66.     case TYPE_INT:
  67.       switch (newtype) 
  68.     {
  69.     case TYPE_RATIONAL:
  70.       { LispObject one = allocate_integer(stackbase+1, 1);
  71.         a = allocate_ratio(stackbase+1, ARG_0(stackbase),one);
  72.         return a;
  73.       }      
  74.     case TYPE_FLOAT:
  75.       return allocate_float(stackbase+1,(double) (intval(a)));
  76.     case TYPE_COMPLEX:
  77.       { LispObject zero = allocate_integer(stackbase+1, 0);
  78.         a = allocate_complex(stackbase+1,ARG_0(stackbase),zero);
  79.         return a;
  80.       }      
  81.     default:
  82.       CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  83.     }
  84.     case TYPE_RATIONAL:
  85.       switch (newtype) {
  86.       case TYPE_FLOAT: 
  87.     CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  88.       case TYPE_COMPLEX:
  89.     { LispObject zero = allocate_integer(stackbase+1, 0);
  90.       a = allocate_complex(stackbase+1,ARG_0(stackbase),zero);
  91.       return a;
  92.     }      
  93.       default:
  94.     CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  95.       }
  96.     case TYPE_FLOAT:
  97.       switch (newtype) {
  98.       case TYPE_COMPLEX:
  99.     { LispObject zero = allocate_integer(stackbase, 0);
  100.       return allocate_complex(stackbase,ARG_0(stackbase), zero);
  101.     }      
  102.       case TYPE_FLOAT:
  103.     return a;
  104.       default:
  105.     CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  106.       }
  107.     default:
  108.       CallError(stackbase,"Unimplemented coercion",a,NONCONTINUABLE);
  109.     }
  110.   return nil;
  111. }
  112.  
  113. EUFUN_2(Fn_eqn, a, b)
  114. {
  115.   if (typeof(a)>typeof(b)) {
  116.     LispObject tmp = a;
  117.     a = b;
  118.     b = tmp;
  119.   }
  120.                 /* types the same is easy!! */
  121.   switch ((typeof(a)<<16)+typeof(b)) {
  122.   case (TYPE_INT<<16)+TYPE_INT:
  123.     return ((intval(a)==intval(b)) ? a : nil);
  124.   case (TYPE_INT<<16)+TYPE_RATIONAL:
  125.   case (TYPE_INT<<16)+TYPE_COMPLEX:
  126.     return nil;
  127.   case (TYPE_INT<<16)+TYPE_FLOAT:
  128.     return (((double)intval(a) == (b->FLOAT).fvalue) ? b : nil);
  129.   case (TYPE_RATIONAL<<16)+TYPE_RATIONAL:
  130.     {
  131.       LispObject ans;
  132.       EUCALLSET_2(ans, Fn_eqn, (a->RATIO).numerator,(b->RATIO).numerator);
  133.       if (ans == nil) return nil;
  134.       EUCALLSET_2(ans, Fn_eqn, (a->RATIO).denominator,(b->RATIO).denominator);
  135.       if (ans == nil) return nil;
  136.       return ARG_0(stackbase);
  137.     }
  138.   case (TYPE_RATIONAL<<16)+TYPE_FLOAT:
  139.     CallError(stacktop,"Unimplemented comparison",a,NONCONTINUABLE);
  140.   case (TYPE_RATIONAL<<16)+TYPE_COMPLEX:
  141.     return nil;
  142.   case (TYPE_FLOAT<<16)+TYPE_FLOAT:
  143.     return ((a->FLOAT).fvalue == (b->FLOAT).fvalue ? a : nil);
  144.   case (TYPE_FLOAT<<16)+TYPE_COMPLEX:
  145.     return nil;
  146.   case (TYPE_COMPLEX<<16)+TYPE_COMPLEX:
  147.     {
  148.       LispObject ans;
  149.       EUCALLSET_2(ans, Fn_eqn, (a->COMPLEX).real,(b->COMPLEX).real);
  150.       if (ans == nil) return nil;
  151.       EUCALLSET_2(ans, Fn_eqn, (a->COMPLEX).imaginary,(b->COMPLEX).imaginary);
  152.       if (ans == nil) return nil;
  153.       return ARG_0(stackbase);
  154.     }
  155.   default:
  156.     CallError(stacktop,"Unimplemented comparison",a,NONCONTINUABLE);
  157.   }
  158.   return nil;
  159. }
  160. EUFUN_CLOSE
  161.  
  162. EUFUN_2(Fn_plus, a, b)
  163. {
  164.   if (typeof(a)>typeof(b)) {
  165.     LispObject tmp;
  166.     tmp = a; a = ARG_0(stackbase) = b; b = ARG_1(stackbase) = tmp;
  167.   }
  168.   if (typeof(a)!=typeof(b)) {
  169.     ARG_0(stacktop) = a;
  170.     a = lift_number(stacktop,typeof(b));
  171.     b = ARG_1(stackbase);
  172.   }
  173.   switch (typeof(a)) {
  174.   case TYPE_INT:
  175.     return allocate_integer(stacktop, intval(a) + intval(b));
  176.   case TYPE_RATIONAL:
  177.     CallError(stacktop,"Unimplemented facility in +",a,NONCONTINUABLE);
  178.   case TYPE_FLOAT:
  179.     return allocate_float(stacktop,(a->FLOAT).fvalue + (b->FLOAT).fvalue);
  180.   case TYPE_COMPLEX:
  181.     {
  182.       LispObject rr;
  183.       LispObject im;
  184.       EUCALLSET_2(rr, Fn_plus, (a->COMPLEX).real, (b->COMPLEX).real);
  185.       EUCALLSET_2(im, Fn_plus, (a->COMPLEX).imaginary, (b->COMPLEX).imaginary);
  186.       return allocate_complex(stacktop,rr,im);
  187.     }
  188.   default:
  189.     CallError(stacktop,"Unimplemented facility in +",a,NONCONTINUABLE);
  190.   }
  191.   return nil;
  192. }
  193. EUFUN_CLOSE
  194.  
  195. EUFUN_2(Fn_difference, a, b)
  196. {
  197.   if (typeof(a)!=typeof(b)) {
  198.     if (typeof(a)<typeof(b)) {
  199.       ARG_0(stacktop) = a;
  200.       ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  201.     }
  202.     else {
  203.       ARG_0(stacktop) = b;
  204.       ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
  205.     }
  206.   }
  207.   switch (typeof(a)) {
  208.   case TYPE_INT:
  209.     return allocate_integer(stacktop, intval(a) - intval(b));
  210.   case TYPE_RATIONAL:
  211.     CallError(stacktop,"Unimplemented facility in -",a,NONCONTINUABLE);
  212.   case TYPE_FLOAT:
  213.     return allocate_float(stacktop,(a->FLOAT).fvalue - (b->FLOAT).fvalue);
  214.   case TYPE_COMPLEX:
  215.     {
  216.       LispObject rr;
  217.       LispObject im;
  218.       EUCALLSET_2(rr, Fn_difference, (a->COMPLEX).real,(b->COMPLEX).real);
  219.       EUCALLSET_2(im, Fn_difference,
  220.               (a->COMPLEX).imaginary,(b->COMPLEX).imaginary);
  221.       return allocate_complex(stacktop,rr,im);
  222.     }
  223.   default:
  224.     CallError(stacktop,"Unimplemented facility in -",a,NONCONTINUABLE);
  225.   }
  226.   return nil;
  227. }
  228. EUFUN_CLOSE
  229.  
  230. EUFUN_2(Fn_times, a, b)
  231. {
  232.   if (typeof(a)>typeof(b)) {
  233.     LispObject tmp;
  234.     tmp = a; a = ARG_0(stackbase) = b; b = ARG_1(stackbase) = tmp;
  235.   }
  236.   if (typeof(a)!=typeof(b)) {
  237.     ARG_0(stacktop) = a;
  238.     ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  239.   }
  240.   switch (typeof(a)) {
  241.   case TYPE_INT:
  242.     return allocate_integer(stacktop, intval(a) * intval(b));
  243.   case TYPE_RATIONAL:
  244.     {
  245.       LispObject num;
  246.       LispObject den;
  247.       EUCALLSET_2(num, Fn_times, (a->RATIO).numerator,(b->RATIO).numerator);
  248.       EUCALLSET_2(den, Fn_times,(a->RATIO).denominator,(b->RATIO).denominator);
  249.       return allocate_ratio(stackbase, num,den); /* Should reduce this */
  250.     }
  251.   case TYPE_FLOAT:
  252.     return allocate_float(stackbase,(a->FLOAT).fvalue * (b->FLOAT).fvalue);
  253.   case TYPE_COMPLEX:
  254.     CallError(stacktop,"Unimplemented facility in *",a,NONCONTINUABLE);
  255.   default:
  256.     CallError(stacktop,"Unimplemented facility in *",a,NONCONTINUABLE);
  257.   }
  258.   return nil;
  259. }
  260. EUFUN_CLOSE
  261.  
  262. EUFUN_2(Fn_divide, a, b)
  263. {
  264.   if (typeof(a)<typeof(b)) {
  265.       ARG_0(stacktop) = a;
  266.       ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  267.     }
  268.   else if (typeof(a)>typeof(b)) {
  269.       ARG_0(stacktop) = b;
  270.       ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
  271.     }
  272.  
  273.   /* Types are equivalent... */
  274.  
  275.   switch(typeof(a)) {
  276.  
  277.   case TYPE_INT:
  278.     return((LispObject) allocate_integer(stackbase, intval(a) / intval(b)));
  279.   case TYPE_RATIONAL:
  280.     {
  281.       LispObject num;
  282.       LispObject den;
  283.       EUCALLSET_2(num, Fn_times,a->RATIO.numerator,b->RATIO.denominator);
  284.       EUCALLSET_2(den, Fn_times,a->RATIO.denominator,b->RATIO.numerator);
  285.       return(allocate_ratio(stackbase,num,den)); /* Not canonical... */
  286.     }
  287.   case TYPE_FLOAT:
  288.     return(allocate_float(stackbase,a->FLOAT.fvalue / b->FLOAT.fvalue));
  289.   case TYPE_COMPLEX:
  290.   default:
  291.     CallError(stacktop,"kernel /: unimplemented facility",a,NONCONTINUABLE);
  292.  
  293.   }
  294.  
  295.   return(nil);
  296. }
  297. EUFUN_CLOSE
  298.  
  299. EUFUN_2(Fn_lessp, a, b)
  300. {
  301.   if (typeof(a)!=typeof(b)) {
  302.   if (typeof(a)<typeof(b)) {
  303.       ARG_0(stacktop) = a;
  304.       ARG_0(stackbase) = a = lift_number(stacktop,typeof(b));
  305.     }
  306.   else {
  307.       ARG_0(stacktop) = b;
  308.       ARG_1(stackbase) = b = lift_number(stacktop,typeof(a));
  309.     }
  310.   }
  311.   switch (typeof(a)) {
  312.   case TYPE_INT:
  313.     return (intval(a) < intval(b) ? lisptrue : nil);
  314.   case TYPE_RATIONAL:
  315.     CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
  316.   case TYPE_FLOAT:
  317.     return ((a->FLOAT).fvalue < (b->FLOAT).fvalue ? lisptrue : nil);
  318.   case TYPE_COMPLEX:
  319.     CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
  320.   default:
  321.     CallError(stacktop,"Unimplemented facility in <",a,NONCONTINUABLE);
  322.   }
  323.   return nil;
  324. }
  325. EUFUN_CLOSE
  326.  
  327. EUFUN_2(Fn_greaterp, a, b)
  328. {
  329.   if (Fn_lessp(stackbase) == nil && Fn_eqn(stackbase) == nil)
  330.     return(lisptrue);
  331.   else
  332.     return(nil);
  333. }
  334. EUFUN_CLOSE
  335.  
  336. LispObject generic_zerop;
  337.  
  338. EUFUN_1( Gf_zerop, i)
  339. {
  340.   return(generic_apply_1(stackbase, generic_zerop,i));
  341. }
  342. EUFUN_CLOSE
  343.  
  344. EUFUN_1( Fn_zerop, a)
  345. {
  346.   switch (typeof(a)) {
  347.   case TYPE_INT:
  348.     return (intval(a) == 0 ? lisptrue : nil);
  349.   case TYPE_BIGNUM:
  350.     return nil;
  351.   case TYPE_RATIONAL:
  352.     ARG_0(stackbase) = (a->RATIO).numerator;
  353.     return Fn_zerop(stackbase);
  354.   case TYPE_FLOAT:
  355.     return ((a->FLOAT).fvalue == (double)0.0E0 ? lisptrue : nil);
  356.   case TYPE_COMPLEX:
  357.     ARG_0(stacktop) = (a->COMPLEX).real;
  358.     if (Fn_zerop(stacktop)==nil) return nil;
  359.     ARG_0(stackbase) = (a->COMPLEX).imaginary;
  360.     return Fn_zerop(stackbase);
  361.   default:
  362.     CallError(stacktop,"Unimplemented facility in zerop",a,NONCONTINUABLE);
  363.   }
  364.   return nil;
  365. }
  366. EUFUN_CLOSE
  367.  
  368. EUFUN_1( Md_zerop_Number, a)
  369. {
  370.   return Fn_zerop(stackbase);
  371. }
  372. EUFUN_CLOSE
  373.  
  374. LispObject generic_abs;
  375.  
  376. EUFUN_1( Gf_abs, i)
  377. {
  378.   return(generic_apply_1(stackbase, generic_abs, i));
  379. }
  380. EUFUN_CLOSE
  381.  
  382. EUFUN_1( Fn_abs,  a)
  383. {
  384.   switch (typeof(a)) {
  385.   case TYPE_INT:
  386.     return (intval(a) < 0 ?
  387.          allocate_integer(stackbase, -intval(a)) : a);
  388.   case TYPE_BIGNUM:
  389.     return nil;
  390.   case TYPE_RATIONAL:
  391.     ARG_0(stacktop) = (a->RATIO).numerator;
  392.     return allocate_ratio(stackbase, Fn_abs(stacktop),(a->RATIO).denominator);
  393.   case TYPE_FLOAT:
  394.     return ((a->FLOAT).fvalue >= (double)0.0E0 ? a :
  395.         allocate_float(stackbase,-(a->FLOAT).fvalue));
  396.   case TYPE_COMPLEX:
  397.     {
  398.       LispObject r = (a->COMPLEX).real;
  399.       LispObject i = (a->COMPLEX).imaginary;
  400.       ARG_0(stacktop) = r;
  401.       ARG_1(stacktop) = r;
  402.       ARG_0(stackbase) = Fn_times(stacktop);
  403.       ARG_0(stacktop) = i;
  404.       ARG_1(stacktop) = i;
  405.       ARG_1(stackbase) = Fn_times(stacktop);
  406.       ARG_0(stackbase) = Fn_plus(stackbase);
  407.       a = lift_number(stackbase, TYPE_FLOAT);
  408.       return allocate_float(stackbase,sqrt((a->FLOAT).fvalue));
  409.     }
  410.   default:
  411.     CallError(stacktop,"Unimplemented facility in abs",a,NONCONTINUABLE);
  412.   }
  413.   return nil;
  414. }
  415. EUFUN_CLOSE
  416.  
  417. EUFUN_1( Md_abs_Number, a)
  418. {
  419.   return Fn_abs(stackbase);
  420. }
  421. EUFUN_CLOSE
  422.  
  423. /* *************************************************************** */
  424. /* Integer Arithmetic                                              */
  425. /* *************************************************************** */
  426.  
  427. EUFUN_1( Fn_fixnump, form)
  428. {
  429.   return (is_fixnum(form) ? lisptrue : nil);
  430. }
  431. EUFUN_CLOSE
  432.  
  433. EUFUN_1( Fn_oddp, form)
  434. {
  435.   while (!is_fixnum(form))
  436.     form = CallError(stacktop,"Not an integer in oddp ",form,CONTINUABLE);
  437.   return (((intval(form)) & 1)==0 ? nil : lisptrue);
  438. }
  439. EUFUN_CLOSE
  440.  
  441. EUFUN_1( Fn_evenp, form)
  442. {
  443.   while (!is_fixnum(form))
  444.     form = CallError(stacktop,"Not an integer in evenp ",form,CONTINUABLE);
  445.   return ((intval(form)) & 1 != 0 ? nil : lisptrue);
  446. }
  447. EUFUN_CLOSE
  448.  
  449. /* *************************************************************** */
  450. /* Floating Point Arithmetic                                       */
  451. /* *************************************************************** */
  452.  
  453. EUFUN_1( Fn_floatp, form)
  454. {
  455.   return (is_float(form) ? lisptrue : nil);
  456. }
  457. EUFUN_CLOSE
  458.  
  459. EUFUN_1( Fn_floor, form)
  460. {
  461.   double n;
  462.  
  463.   while (!is_number(form))
  464.     form = CallError(stacktop,"Not a number in floor ",form,CONTINUABLE);
  465.   form = lift_number(stackbase, TYPE_FLOAT);
  466.   n = floor((form->FLOAT).fvalue);
  467.   if (- (double)16777216.0 < n && n < (double)16777216.0)
  468.     return allocate_integer(stackbase, (int)n);
  469.   fprintf(stderr,"Floor to a bignum missing\n");
  470.   return nil;
  471. }
  472. EUFUN_CLOSE
  473.  
  474. EUFUN_1( Fn_ceiling, form)
  475. {
  476.   double n;
  477.  
  478.   while (!is_number(form))
  479.     form = CallError(stacktop,"Not a number in ceiling ",form,CONTINUABLE);
  480.   form = lift_number(stackbase, TYPE_FLOAT);
  481.   n = ceil((form->FLOAT).fvalue);
  482.   if (- (double)16777216.0 < n && n < (double)16777216.0)
  483.     return allocate_integer(stackbase, (int)n);
  484.   fprintf(stderr,"Ceiling to a bignum missing\n");
  485.   return nil;
  486. }
  487. EUFUN_CLOSE
  488.  
  489. EUFUN_1( Fn_truncate, f)
  490. {
  491.   if (is_fixnum(f)) return(f);
  492.   if (is_float(f)) {
  493.     long down;
  494.  
  495.     down = (long) floor(f->FLOAT.fvalue);
  496.     if ((double) abs((int) down) > f->FLOAT.fvalue) down += 1;
  497.     return (LispObject) allocate_integer(stackbase, (int) down);
  498.   }
  499.   CallError(stacktop,"truncate: no way",f,NONCONTINUABLE);
  500.  
  501.   return(nil);
  502. }
  503. EUFUN_CLOSE
  504.  
  505. EUFUN_1( Fn_round, f)
  506. {
  507.   if (is_fixnum(f)) return(f);
  508.   if (is_float(f)) {
  509.     long down;
  510.  
  511.     down = (long) floor(f->FLOAT.fvalue + (double) 0.5);
  512.     return (LispObject) allocate_integer(stackbase, (int) down);
  513.   }
  514.   CallError(stacktop,"round: no way",f,NONCONTINUABLE);
  515.  
  516.   return(nil);
  517. }
  518. EUFUN_CLOSE  
  519.     
  520. /* *************************************************************** */
  521. /* Floating Point Arithmetic                                       */
  522. /* *************************************************************** */
  523.  
  524. EUFUN_1( Fn_cos, form)
  525. {
  526.   while (!is_number(form))
  527.     form = CallError(stacktop,"Not a number in cos ",form,CONTINUABLE);
  528.   form = lift_number(stackbase, TYPE_FLOAT);
  529.   return allocate_float(stackbase,cos((form->FLOAT).fvalue));
  530. }
  531. EUFUN_CLOSE 
  532.  
  533. EUFUN_1( Fn_sin, form)
  534. {
  535.   while (!is_number(form))
  536.     form = CallError(stacktop,"Not a number in sin ",form,CONTINUABLE);
  537.   form = lift_number(stackbase, TYPE_FLOAT);
  538.   return allocate_float(stackbase,sin((form->FLOAT).fvalue));
  539. }
  540. EUFUN_CLOSE
  541.  
  542. EUFUN_1( Fn_sqrt, form)
  543. {
  544.   while (!is_number(form))
  545.     form = CallError(stacktop,"Not a number in sin ",form,CONTINUABLE);
  546.   form = lift_number(stackbase, TYPE_FLOAT);
  547.   return allocate_float(stackbase,sqrt((form->FLOAT).fvalue));
  548. }
  549. EUFUN_CLOSE
  550.   
  551. EUFUN_1( Fn_exp, form)
  552. {
  553.   while (!is_number(form))
  554.     form = CallError(stacktop,"Not a number in exp ",form,CONTINUABLE);
  555.   form = lift_number(stackbase, TYPE_FLOAT);
  556.   return allocate_float(stackbase,exp((form->FLOAT).fvalue));
  557. }
  558. EUFUN_CLOSE
  559.  
  560.                 /* This function does not check correctly */
  561. EUFUN_1( Fn_log, form)
  562. {
  563.   LispObject base, arg1;
  564.   while (!is_cons(form))
  565.     form = CallError(stacktop,"No argument(s) to log ",form,CONTINUABLE);
  566.   arg1 = CAR(form);
  567.   ARG_1(stackbase)=CAR(form);
  568.   while (!is_number(arg1))
  569.     ARG_0(stacktop) = CallError(stacktop,"Not a number in log ",arg1,CONTINUABLE);
  570.   arg1 = lift_number(stackbase+1, TYPE_FLOAT);
  571.   if (is_cons(CDR(form))) 
  572.     {
  573.       base = CAR(CDR(form));
  574.       while (!is_number(base))
  575.     base = CallError(stacktop,"Not a base in log ",base,CONTINUABLE);
  576.       ARG_0(stackbase) = arg1;
  577.       ARG_1(stackbase) = base;
  578.       base = lift_number(stackbase+1, TYPE_FLOAT);
  579.       return
  580.     allocate_float(stackbase,
  581.                log((ARG_0(stackbase)->FLOAT).fvalue) 
  582.                / log(base->FLOAT.fvalue));
  583.     }
  584.   else
  585.     return allocate_float(stackbase,log((arg1->FLOAT).fvalue));
  586. }
  587. EUFUN_CLOSE
  588.  
  589. EUFUN_1( Fn_acos, form)
  590. {
  591.   while (!is_number(form))
  592.     form = CallError(stacktop,"Not a number in acos ",form,CONTINUABLE);
  593.   form = lift_number(stackbase, TYPE_FLOAT);
  594.   return allocate_float(stackbase,acos((form->FLOAT).fvalue));
  595. }
  596. EUFUN_CLOSE
  597.  
  598. EUFUN_1( Fn_asin, form)
  599. {
  600.   while (!is_number(form))
  601.     form = CallError(stacktop,"Not a number in asin ",form,CONTINUABLE);
  602.   form = lift_number(stackbase, TYPE_FLOAT);
  603.   return allocate_float(stacktop,asin((form->FLOAT).fvalue));
  604. }
  605. EUFUN_CLOSE
  606.  
  607. EUFUN_1( Fn_atan, form)
  608. {
  609.   while (!is_number(form))
  610.     form = CallError(stacktop,"Not a number in atan ",form,CONTINUABLE);
  611.   form = lift_number(stackbase, TYPE_FLOAT);
  612.   return allocate_float(stacktop,atan((form->FLOAT).fvalue));
  613. }
  614. EUFUN_CLOSE
  615.  
  616. EUFUN_2( Fn_atan2, form1, form2)
  617. {
  618.   while (!is_number(form1))
  619.     form1 = CallError(stacktop,"Not a number in atan2 ",form1,CONTINUABLE);
  620.   ARG_0(stacktop) = form1;
  621.   ARG_0(stackbase) = lift_number(stacktop, TYPE_FLOAT);
  622.   while (!is_number(form2))
  623.     form2 = CallError(stacktop,"Not a number in atan2 ",form2,CONTINUABLE);
  624.   form2 = lift_number(stackbase+1, TYPE_FLOAT);
  625.   form1 = ARG_0(stackbase);
  626.   return allocate_float(stacktop,
  627.             atan2((form1->FLOAT).fvalue,(form2->FLOAT).fvalue));
  628. }
  629. EUFUN_CLOSE
  630.  
  631. EUFUN_1( Fn_tan, form)
  632. {
  633.   while (!is_number(form))
  634.     form = CallError(stacktop,"Not a number in tan ",form,CONTINUABLE);
  635.   form = lift_number(stackbase, TYPE_FLOAT);
  636.   return allocate_float(stacktop,tan((form->FLOAT).fvalue));
  637. }
  638. EUFUN_CLOSE
  639.  
  640. EUFUN_1( Fn_acosh, form)
  641. {
  642.   double x;
  643.   while (!is_number(form))
  644.     form = CallError(stacktop,"Not a number in acosh ",form,CONTINUABLE);
  645.   form = lift_number(stackbase, TYPE_FLOAT);
  646.   x = (form->FLOAT).fvalue;
  647.   return allocate_float(stackbase,log(x+sqrt(x*x-1)));
  648. }
  649. EUFUN_CLOSE
  650.  
  651. EUFUN_1( Fn_asinh, form)
  652. {
  653.   double x;
  654.   while (!is_number(form))
  655.     form = CallError(stacktop,"Not a number in asinh ",form,CONTINUABLE);
  656.   form = lift_number(stackbase, TYPE_FLOAT);
  657.   x = (form->FLOAT).fvalue;
  658.   return allocate_float(stackbase,log(x+sqrt(x*x+1)));
  659. }
  660. EUFUN_CLOSE
  661.  
  662. EUFUN_1( Fn_atanh, form)
  663. {
  664.   double x;
  665.   while (!is_number(form))
  666.     form = CallError(stacktop,"Not a number in atanh ",form,CONTINUABLE);
  667.   form = lift_number(stackbase, TYPE_FLOAT);
  668.   x = (form->FLOAT).fvalue;
  669.   return allocate_float(stackbase,0.5*(log((x+1.0)/(x-1.0))));
  670. }
  671. EUFUN_CLOSE
  672.  
  673. EUFUN_1( Fn_cosh, form)
  674. {
  675.   while (!is_number(form))
  676.     form = CallError(stacktop,"Not a number in cosh ",form,CONTINUABLE);
  677.   form = lift_number(stackbase, TYPE_FLOAT);
  678.   return allocate_float(stackbase,cosh((form->FLOAT).fvalue));
  679. }
  680. EUFUN_CLOSE
  681.  
  682. EUFUN_1( Fn_sinh, form)
  683. {
  684.   while (!is_number(form))
  685.     form = CallError(stacktop,"Not a number in sinh ",form,CONTINUABLE);
  686.   form = lift_number(stackbase, TYPE_FLOAT);
  687.   return allocate_float(stackbase,sinh((form->FLOAT).fvalue));
  688. }
  689. EUFUN_CLOSE
  690.  
  691. EUFUN_1( Fn_tanh, form)
  692. {
  693.   while (!is_number(form))
  694.     form = CallError(stacktop,"Not a number in tanh ",form,CONTINUABLE);
  695.   form = lift_number(stackbase, TYPE_FLOAT);
  696.   return allocate_float(stackbase,tanh((form->FLOAT).fvalue));
  697. }
  698. EUFUN_CLOSE
  699.  
  700. /* Generic versions... */
  701.  
  702. LispObject generic_eqn;
  703.  
  704. EUFUN_2(Gf_eqn, i1, i2)
  705. {
  706.   return(generic_apply_2(stackbase, generic_eqn, i1, i2));
  707. }
  708. EUFUN_CLOSE
  709.  
  710. EUFUN_2(Md_eqn_Number_Number, i1, i2)
  711. {
  712.   return(Fn_eqn(stackbase));
  713. }
  714. EUFUN_CLOSE
  715.  
  716. LispObject generic_binary_plus;
  717.  
  718. EUFUN_2(Gf_binary_plus, a, b)
  719. {
  720.   return(generic_apply_2(stackbase, generic_binary_plus, a, b));
  721. }
  722. EUFUN_CLOSE
  723.  
  724. EUFUN_2(Md_binary_plus_Object_Object, n1, n2)
  725. {
  726.   return(Fn_plus(stackbase));
  727. }
  728. EUFUN_CLOSE
  729.  
  730. EUFUN_2( Md_binary_plus_Integer_Integer, i1, i2)
  731. {
  732.   return((LispObject)allocate_integer(stackbase, intval(i1)+intval(i2)));
  733. }
  734. EUFUN_CLOSE
  735.  
  736. LispObject generic_binary_difference;
  737.  
  738. EUFUN_2( Gf_binary_difference, a, b)
  739. {
  740.   return(generic_apply_2(stackbase, generic_binary_difference,a, b));
  741. }
  742. EUFUN_CLOSE
  743.  
  744. EUFUN_2( Md_binary_difference_Object_Object, n1, n2)
  745. {
  746.   return(Fn_difference(stackbase));
  747. }
  748. EUFUN_CLOSE
  749.  
  750. EUFUN_2( Md_binary_difference_Integer_Integer, i1, i2)
  751. {
  752.   return((LispObject)allocate_integer(stackbase, intval(i1)-intval(i2)));
  753. }
  754. EUFUN_CLOSE
  755.  
  756. LispObject generic_binary_times;
  757.  
  758. EUFUN_2( Gf_binary_times, a, b)
  759. {
  760.   return(generic_apply_2(stackbase, generic_binary_times, a, b));
  761. }
  762. EUFUN_CLOSE
  763.  
  764. EUFUN_2( Md_binary_times_Object_Object, n1, n2)
  765. {
  766.   return(Fn_times(stackbase));
  767. }
  768. EUFUN_CLOSE
  769.  
  770. EUFUN_2( Md_binary_times_Integer_Integer, i1, i2)
  771. {
  772.   return((LispObject)allocate_integer(stackbase, intval(i1)*intval(i2)));
  773. }
  774. EUFUN_CLOSE
  775.  
  776. LispObject generic_binary_divide;
  777.  
  778. EUFUN_2( Gf_binary_divide, a, b)
  779. {
  780.   return(generic_apply_2(stackbase, generic_binary_divide, a, b));
  781. }
  782. EUFUN_CLOSE
  783.  
  784. EUFUN_2( Md_binary_divide_Object_Object, n1, n2)
  785. {
  786.   return(Fn_divide(stackbase));
  787. }
  788. EUFUN_CLOSE
  789.  
  790. EUFUN_2( Md_binary_divide_Integer_Integer, i1, i2)
  791. {
  792.   return((LispObject) allocate_integer(stacktop, intval(i1)/intval(i2)));
  793. }
  794. EUFUN_CLOSE
  795.  
  796. /* Wrappers... */
  797.  
  798. EUFUN_1( Fn_nary_plus, args)
  799. {
  800.   LispObject walker;
  801.   LispObject n1,n2;
  802.  
  803.   walker = args;
  804.  
  805.   if (!is_cons(walker))
  806.     CallError(stacktop,"+: no arguments",args,NONCONTINUABLE);
  807.  
  808.   n1 = CAR(walker); walker = CDR(walker);
  809.  
  810.   if (!is_cons(walker))
  811.     CallError(stacktop,"+: insufficient arguments",args,NONCONTINUABLE);
  812.  
  813.   n2 = CAR(walker); walker = CDR(walker);
  814.   n1 = generic_apply_2(stacktop, generic_binary_plus, n1, n2);
  815.  
  816.   while (is_cons(walker)) {
  817.     STACK_TMP(CDR(walker));
  818.     n1 = generic_apply_2(stacktop, generic_binary_plus, n1, CAR(walker));
  819.     UNSTACK_TMP(walker);
  820.   }
  821.  
  822.   return(n1);
  823. }
  824. EUFUN_CLOSE
  825.  
  826. EUFUN_1( Fn_nary_difference, args)
  827. {
  828.   LispObject walker;
  829.   LispObject n1,n2;
  830.  
  831.   walker = args;
  832.  
  833.   if (!is_cons(walker))
  834.     CallError(stacktop,"-: no arguments",args,NONCONTINUABLE);
  835.  
  836.   n1 = CAR(walker); walker = CDR(walker);
  837.  
  838.   if (!is_cons(walker)) {
  839.     LispObject xx;
  840.     STACK_TMP(n1);
  841.     xx = allocate_integer(stacktop, 0);
  842.     UNSTACK_TMP(n1);
  843.     return(generic_apply_2(stackbase, generic_binary_difference,xx, n1));
  844.   }
  845.  
  846.   n2 = CAR(walker); STACK_TMP(CDR(walker));
  847.   n1 = generic_apply_2(stacktop, generic_binary_difference,n1, n2);
  848.   UNSTACK_TMP(walker);
  849.  
  850.   while (is_cons(walker)) {
  851.     STACK_TMP(CDR(walker));
  852.     n1 = generic_apply_2(stacktop, generic_binary_difference,n1, CAR(walker));
  853.     UNSTACK_TMP(walker);
  854.   }
  855.  
  856.   return(n1);
  857. }
  858. EUFUN_CLOSE
  859.  
  860. EUFUN_1( Fn_nary_times, args)
  861. {
  862.   LispObject walker;
  863.   LispObject n1,n2;
  864.  
  865.   walker = args;
  866.  
  867.   if (!is_cons(walker))
  868.     CallError(stacktop,"*: no arguments",args,NONCONTINUABLE);
  869.  
  870.   n1 = CAR(walker); walker = CDR(walker);
  871.  
  872.   if (!is_cons(walker))
  873.     CallError(stacktop,"*: insufficient arguments",args,NONCONTINUABLE);
  874.  
  875.   STACK_TMP(CDR(walker));
  876.   n1 = generic_apply_2(stacktop, generic_binary_times, n1, CAR(walker));
  877.   UNSTACK_TMP(walker);
  878.  
  879.   while (is_cons(walker)) {
  880.     STACK_TMP(CDR(walker));
  881.     n1 = generic_apply_2(stacktop, generic_binary_times,n1, CAR(walker));
  882.     UNSTACK_TMP(walker);
  883.   }
  884.  
  885.   return(n1);
  886. }
  887. EUFUN_CLOSE
  888.  
  889. EUFUN_1( Fn_nary_divide, args)
  890. {
  891.   LispObject walker;
  892.   LispObject n1,n2;
  893.  
  894.   walker = args;
  895.  
  896.   if (!is_cons(walker))
  897.     CallError(stacktop,"/: no arguments",args,NONCONTINUABLE);
  898.  
  899.   n1 = CAR(walker); walker = CDR(walker);
  900.  
  901.   if (!is_cons(walker))
  902.     CallError(stacktop,"/: insufficient arguments",args,NONCONTINUABLE);
  903.  
  904.   STACK_TMP(CDR(walker));
  905.   n1 = generic_apply_2(stacktop, generic_binary_divide, n1, CAR(walker));
  906.   UNSTACK_TMP(walker);
  907.  
  908.   while (is_cons(walker)) {
  909.     STACK_TMP(CDR(walker));
  910.     n1 = generic_apply_2(stacktop, generic_binary_divide,n1, CAR(walker));
  911.     UNSTACK_TMP(walker);
  912.   }
  913.  
  914.   return(n1);
  915. }
  916. EUFUN_CLOSE
  917.  
  918. /*
  919.  * Integer operations...
  920.  */
  921.  
  922. EUFUN_2(Fn_quotient, n, m)
  923. {
  924.   if (!is_fixnum(n))
  925.     CallError(stacktop,"quotient: not an integer",n,NONCONTINUABLE);
  926.  
  927.   if (!is_fixnum(m))
  928.     CallError(stacktop,"quotient: not an integer",m,NONCONTINUABLE);
  929.  
  930.   return((LispObject) allocate_integer(stackbase, intval(n)/intval(m)));
  931. }
  932. EUFUN_CLOSE
  933.  
  934. EUFUN_2(Fn_remainder, n, m)
  935. {
  936.  
  937.   if (!is_fixnum(n))
  938.     CallError(stacktop,"remainder(hack): non-integer as argument",n,NONCONTINUABLE);
  939.  
  940.   if (!is_fixnum(m))
  941.     CallError(stacktop,"remainder(hack): non-integer as argument",m,NONCONTINUABLE);
  942.  
  943.   return((LispObject) allocate_integer(stackbase, intval(n)%intval(m)));
  944.  
  945. }
  946. EUFUN_CLOSE
  947.  
  948. /*
  949.  * GCD calculation.
  950.  */
  951.  
  952. LispObject generic_binary_gcd;
  953.  
  954. EUFUN_2(Gf_binary_gcd, n1, n2)
  955. {
  956.   return(generic_apply_2(stackbase, generic_binary_gcd,n1, n2));
  957. }
  958. EUFUN_CLOSE
  959.  
  960. EUFUN_2( Md_binary_gcd_Integer_Integer, n1, n2)
  961. {
  962.   extern int abs(int);
  963.   int a,b,r;
  964.   LispObject ans;
  965.  
  966.   a = abs(intval(n1)); b = abs(intval(n2));
  967.  
  968.   do {
  969.     
  970.     r = a%b;
  971.     a = b; b = r;
  972.  
  973.   } while(b != 0);
  974.  
  975.   return (LispObject) allocate_integer(stackbase, a);
  976.  
  977.   return(ans);
  978. }
  979. EUFUN_CLOSE
  980.  
  981. EUFUN_1( Fn_gcd, args)
  982. {
  983.   LispObject v1,v2;
  984.  
  985.   if (intval(Fn_length(stackbase)) < 2)
  986.     CallError(stacktop,"gcd: insufficient arguments",args,NONCONTINUABLE);
  987.   
  988.   v1 = CAR(args); args = CDR(args);
  989.  
  990.   while (is_cons(args)) {
  991.  
  992.     ARG_0(stacktop) = v1;
  993.     ARG_1(stacktop)= v2 = CAR(args); ARG_0(stackbase) = CDR(args);
  994.     v1 = Gf_binary_gcd(stacktop);
  995.     args = ARG_0(stackbase);
  996.     
  997.   }
  998.  
  999.   return(v1);
  1000. }
  1001. EUFUN_CLOSE
  1002.  
  1003. /*
  1004.  * LCM calculation.
  1005.  */
  1006.  
  1007. LispObject generic_binary_lcm;
  1008.  
  1009. EUFUN_2(Gf_binary_lcm, n1, n2)
  1010. {
  1011.   return(generic_apply_2(stackbase, generic_binary_lcm, n1, n2));
  1012. }
  1013. EUFUN_CLOSE
  1014.  
  1015. EUFUN_2( Md_binary_lcm_Integer_Integer, n1, n2)
  1016. {
  1017.   extern int abs(int);
  1018.   int a,b,r,origa,origb;
  1019.  
  1020.   a = abs(intval(n1)); b = abs(intval(n2));
  1021.   origa = a; origb = b;
  1022.   do {
  1023.     r = a%b;
  1024.     a = b; b = r;
  1025.   } while(b != 0);
  1026.  
  1027.   a = (origa/a)*origb;
  1028.   return (LispObject) allocate_integer(stackbase, a);
  1029. }
  1030. EUFUN_CLOSE
  1031.  
  1032. EUFUN_1( Fn_lcm, args)
  1033. {
  1034.   LispObject v1,v2;
  1035.   
  1036.   if (intval(Fn_length(stackbase)) < 2)
  1037.     CallError(stacktop,"lcm: insufficient arguments",args,NONCONTINUABLE);
  1038.   v1 = CAR(args); args = CDR(args);
  1039.   while (is_cons(args)) {
  1040.     ARG_0(stacktop) = v1;
  1041.     ARG_1(stacktop) = v2 = CAR(args); ARG_0(stackbase) = CDR(args);
  1042.     v1 = Gf_binary_lcm(stacktop);
  1043.     args = ARG_0(stackbase);
  1044.   }
  1045.  
  1046.   return(v1);
  1047. }
  1048. EUFUN_CLOSE
  1049.  
  1050. /* *************************************************************** */
  1051. /*                           Ordering                              */
  1052. /* *************************************************************** */  
  1053.  
  1054. LispObject generic_binary_lt;
  1055.  
  1056. EUFUN_2(Gf_binary_lt, a, b)
  1057. {
  1058.   return(generic_apply_2(stackbase, generic_binary_lt, a, b));
  1059. }
  1060. EUFUN_CLOSE
  1061.  
  1062. EUFUN_2(Md_binary_lt_Number, a, b)
  1063. {
  1064.   return(Fn_lessp(stackbase));
  1065. }
  1066. EUFUN_CLOSE
  1067.  
  1068. EUFUN_2(Md_binary_lt_Integer, a, b)
  1069. {
  1070.   return(intval(a)<intval(b) ? lisptrue : nil);
  1071. }
  1072. EUFUN_CLOSE
  1073.  
  1074.  
  1075. EUFUN_1( Fn_lt, args)
  1076. {
  1077.   LispObject a;
  1078.  
  1079.   if (!is_cons(args))
  1080.     CallError(stacktop,"<: insufficient arguments",args,NONCONTINUABLE);
  1081.  
  1082.   a = CAR(args); args = CDR(args);
  1083.   
  1084.   if (!is_cons(args)) return(lisptrue);
  1085.  
  1086.   while (is_cons(args)) {
  1087.     ARG_0(stacktop) = a;
  1088.     ARG_1(stacktop) = CAR(args);
  1089.     if (Gf_binary_lt(stacktop) == nil) return(nil);
  1090.     a = CAR(args);
  1091.     args = CDR(args);
  1092.     ARG_0(stackbase) = args;
  1093.   }
  1094.  
  1095.   return(lisptrue);
  1096. }
  1097. EUFUN_CLOSE
  1098.  
  1099.  
  1100. LispObject generic_binary_gt;
  1101.  
  1102. EUFUN_2(Gf_binary_gt, a, b)
  1103. {
  1104.   return(generic_apply_2(stackbase, generic_binary_gt,a, b));
  1105. }
  1106. EUFUN_CLOSE
  1107.  
  1108. EUFUN_2(Md_binary_gt_Number, a, b)
  1109. {
  1110.   ARG_0(stackbase) = b;
  1111.   ARG_1(stackbase) = a;
  1112.   return(Gf_binary_lt(stackbase));
  1113. }
  1114. EUFUN_CLOSE
  1115.  
  1116. EUFUN_2(Md_binary_gt_Integer, a, b)
  1117. {
  1118.   return(intval(a)>intval(b) ? lisptrue : nil);
  1119. }
  1120. EUFUN_CLOSE
  1121.  
  1122. EUFUN_1( Fn_gt, args)
  1123. {
  1124.   LispObject a;
  1125.  
  1126.   if (!is_cons(args))
  1127.     CallError(stacktop,">: insufficient arguments",args,NONCONTINUABLE);
  1128.  
  1129.   a = CAR(args); args = CDR(args);
  1130.   
  1131.   if (!is_cons(args)) return(lisptrue);
  1132.  
  1133.   while (is_cons(args)) {
  1134.     ARG_0(stacktop) = a;
  1135.     ARG_1(stacktop) = CAR(args);
  1136.     if (Gf_binary_gt(stacktop) == nil) return(nil);
  1137.     a = CAR(args);
  1138.     args = CDR(args);
  1139.     ARG_0(stackbase) = args;
  1140.   }
  1141. #ifdef jpff_version /* Fri Sep  6 17:51:33 1991 */
  1142. /**/  while (is_cons(args)) {
  1143. /**/    ARG_0(stacktop) = a;
  1144. /**/    ARG_1(stacktop) = CAR(args); 
  1145. /**/    ARG_0(stackbase) = CDR(args);
  1146. /**/    if (Gf_binary_gt(stacktop) == nil) return(nil);
  1147. /**/    a = ARG_1(stacktop);
  1148. /**/    args = ARG_0(stackbase);
  1149. /**/  }
  1150. #endif /* jpff's version Fri Sep  6 17:51:33 1991 */
  1151.  
  1152.   return(lisptrue);
  1153. }
  1154. EUFUN_CLOSE
  1155.  
  1156. EUFUN_1( Fn_lt_or_equal, args)
  1157. {
  1158.   LispObject a;
  1159.  
  1160.   if (!is_cons(args))
  1161.     CallError(stacktop,"<=: insufficient arguments",args,NONCONTINUABLE);
  1162.  
  1163.   a = CAR(args); args = CDR(args);
  1164.  
  1165.   STACK_TMP(args);
  1166.   if (!is_cons(args)) return(lisptrue);
  1167.  
  1168.   while (is_cons(args)) {
  1169.     ARG_0(stacktop) = a;
  1170.     ARG_1(stacktop) = CAR(args);
  1171.     if (Gf_binary_lt(stacktop) == nil && EUCALL_2(Gf_eqn,a,CAR(args)) == nil)
  1172.       return nil;
  1173.     a = CAR(args);
  1174.  
  1175.     args = CDR(args);
  1176.     ARG_0(stackbase) = args;
  1177.   }
  1178.  
  1179.   return(lisptrue);
  1180. }
  1181. EUFUN_CLOSE
  1182.  
  1183. EUFUN_1( Fn_gt_or_equal, args)
  1184. {
  1185.   LispObject a;
  1186.  
  1187.   if (!is_cons(args))
  1188.     CallError(stacktop,">=: insufficient arguments",args,NONCONTINUABLE);
  1189.  
  1190.   a = CAR(args); args = CDR(args);
  1191.   ARG_0(stackbase)=args;
  1192.   if (!is_cons(args)) return(lisptrue);
  1193.  
  1194.   while (is_cons(args)) {
  1195.     ARG_0(stacktop) = a;
  1196.     ARG_1(stacktop) = CAR(args);
  1197.     if (Gf_binary_gt(stacktop) == nil && EUCALL_2(Gf_eqn,a,CAR(args)) == nil)
  1198.       return nil;
  1199.     a = CAR(args);
  1200.     args = CDR(args);
  1201.     ARG_0(stackbase) = args;
  1202.   }
  1203.  
  1204.   return(lisptrue);
  1205. }
  1206. EUFUN_CLOSE
  1207.  
  1208. LispObject generic_max;
  1209.  
  1210. EUFUN_2(Gf_max, a, b)
  1211. {
  1212.   return(generic_apply_2(stackbase, generic_max, a, b));
  1213. }
  1214. EUFUN_CLOSE
  1215.  
  1216. EUFUN_2(Md_max_Number_Number, a, b)
  1217. {
  1218.   if (EUCALL_2(Gf_binary_lt, a,b) != nil) return(ARG_1(stackbase));
  1219.   return(ARG_0(stackbase));
  1220. }
  1221. EUFUN_CLOSE
  1222.  
  1223. EUFUN_1( Fn_min, a)
  1224. {
  1225.   LispObject ans,xxx;
  1226.   while (!is_cons(a))
  1227.     a = CallError(stacktop,"Too few arguments for min ",a,CONTINUABLE);
  1228.   ans = CAR(a);
  1229.   a = CDR(a);
  1230.   while (!is_number(ans))
  1231.     ans = CallError(stacktop,"Non numeric argument for min ",ans,CONTINUABLE);
  1232.   while (a != nil) {
  1233.     LispObject b = CAR(a);
  1234.     while (!is_number(b)) 
  1235.       b = CallError(stacktop,"Non numeric argument for min ",b,CONTINUABLE);
  1236.     ARG_0(stackbase) = a;
  1237.     STACK_TMP(ans);
  1238.     STACK_TMP(b);
  1239.     ARG_0(stacktop) = ans;
  1240.     ARG_1(stacktop) = b;
  1241.     xxx = Md_max_Number_Number(stacktop);
  1242.     UNSTACK_TMP(b);
  1243.     UNSTACK_TMP(ans);
  1244.     if (xxx == ans)
  1245.       ans = b;
  1246.     else /*ans = ans */;
  1247.     a = CDR(ARG_0(stackbase));
  1248.   }
  1249.   return(ans);
  1250. }
  1251. EUFUN_CLOSE
  1252.  
  1253. EUFUN_1( Fn_max, a)
  1254. {
  1255.   LispObject ans,xxx;
  1256.   while (!is_cons(a))
  1257.     a = CallError(stacktop,"Too few arguments for max ",a,CONTINUABLE);
  1258.   ans = CAR(a);
  1259.   a = CDR(a);
  1260.   while (!is_number(ans))
  1261.     ans = CallError(stacktop,"Non numeric argument for max ",ans,CONTINUABLE);
  1262.   while (a != nil) {
  1263.     LispObject b = CAR(a);
  1264.     while (!is_number(b)) 
  1265.       b = CallError(stacktop,"Non numeric argument for max ",b,CONTINUABLE);
  1266.     ARG_0(stackbase) = a;
  1267.     STACK_TMP(ans);
  1268.     STACK_TMP(b);
  1269.     ARG_0(stacktop) = ans;
  1270.     ARG_1(stacktop) = b;
  1271.     xxx = Md_max_Number_Number(stacktop);
  1272.     UNSTACK_TMP(b); 
  1273.     UNSTACK_TMP(ans);
  1274.     if (xxx == b)
  1275.       ans = b;
  1276.     else /* ans = ans */;
  1277.     a = CDR(ARG_0(stackbase));
  1278.   }
  1279.   return(ans);
  1280. }
  1281. EUFUN_CLOSE
  1282.  
  1283. /* *************************************************************** */
  1284. /* COMPLEX NUMBERS                                                 */
  1285. /* *************************************************************** */
  1286.  
  1287. EUFUN_2( Fn_Make_Rectangular, x, y)
  1288. {
  1289.   while (!is_number(x) || (typeof(x)== TYPE_COMPLEX))
  1290.     x = CallError(stacktop,"make-rectangular: first argument not valid number",
  1291.           x,CONTINUABLE);
  1292.   while (!is_number(y) || (typeof(y)==TYPE_COMPLEX))
  1293.     y = CallError(stacktop,"make-rectangular: second argument not valid number",
  1294.           y,CONTINUABLE);
  1295.   return allocate_complex(stackbase,x,y);
  1296. }
  1297. EUFUN_CLOSE
  1298.  
  1299. EUFUN_1( Fn_Real_Part, obj)
  1300. {
  1301.   while (!is_number(obj))
  1302.     obj = CallError(stacktop,"Not a number in real-part",obj,CONTINUABLE);
  1303.   if (typeof(obj)==TYPE_COMPLEX)
  1304.     return obj->COMPLEX.real;
  1305.   else return obj;
  1306. }
  1307. EUFUN_CLOSE
  1308.  
  1309. EUFUN_1( Fn_Imaginary_Part, obj)
  1310. {
  1311.   while (!is_number(obj))
  1312.     obj = CallError(stacktop,"Not a number in imaginary-part",obj,CONTINUABLE);
  1313.   if (typeof(obj)==TYPE_COMPLEX)
  1314.     return obj->COMPLEX.imaginary;
  1315.   else return allocate_float(stackbase,(double)0.0);
  1316. }
  1317. EUFUN_CLOSE
  1318.  
  1319. /* *************************************************************** */
  1320. /* RATIONAL NUMBERS                                                */
  1321. /* *************************************************************** */
  1322.  
  1323. EUFUN_1( Fn_Numerator, obj)
  1324. {
  1325.   while (!is_number(obj))
  1326.     obj = CallError(stacktop,"Not a number in numerator",obj,CONTINUABLE);
  1327.   if (typeof(obj)==TYPE_RATIONAL)
  1328.     return obj->RATIO.numerator;
  1329.   else return obj;
  1330. }
  1331. EUFUN_CLOSE
  1332.  
  1333. EUFUN_1( Fn_Denominator, obj)
  1334. {
  1335.   while (!is_number(obj))
  1336.     obj = CallError(stacktop,"Not a number in denominator",obj,CONTINUABLE);
  1337.   if (typeof(obj)==TYPE_RATIONAL)
  1338.     return obj->RATIO.denominator;
  1339.   else return allocate_integer(stackbase, 1);
  1340. }
  1341. EUFUN_CLOSE
  1342.  
  1343.  
  1344.  
  1345. /* *************************************************************** */
  1346. /* Initialisation of this section                                  */
  1347. /* *************************************************************** */
  1348.  
  1349. #define ARITH_ENTRIES 75
  1350. MODULE Module_arith;
  1351. LispObject Module_arith_values[ARITH_ENTRIES];
  1352.  
  1353. void initialise_arith(LispObject *stacktop)
  1354. {
  1355.   extern LispObject generic_equal;
  1356.  
  1357.   open_module(stacktop,
  1358.           &Module_arith,
  1359.           Module_arith_values,
  1360.           "arith",
  1361.           ARITH_ENTRIES);
  1362.  
  1363.   (void) make_module_function(stacktop,"numberp",Fn_numberp,1);
  1364.  
  1365.   generic_binary_plus 
  1366.     = make_wrapped_module_generic(stacktop,"binary-plus",2,Gf_binary_plus);
  1367.   add_root(&generic_binary_plus);
  1368.   (void) make_module_function(stacktop,"generic_binary_plus,Number,Number",
  1369.                   Md_binary_plus_Object_Object,2
  1370.                   );
  1371.  
  1372. #ifndef WITH_BIGNUMS
  1373.   (void) make_module_function(stacktop,"generic_binary_plus,Integer,Integer",
  1374.                   Md_binary_plus_Integer_Integer,2
  1375.                   );
  1376. #endif
  1377.  
  1378.   (void) make_module_function(stacktop,"+",Fn_nary_plus,-1);
  1379.  
  1380.   generic_binary_difference 
  1381.     = make_wrapped_module_generic(stacktop,"binary-difference",2,Gf_binary_difference);
  1382.   add_root(&generic_binary_difference);
  1383.   (void) make_module_function(stacktop,"generic_binary_difference,Number,Number",
  1384.                   Md_binary_difference_Object_Object,2
  1385.                   );
  1386.  
  1387. #ifndef WITH_BIGNUMS
  1388.   (void) make_module_function(stacktop,"generic_binary_difference,Integer,Integer",
  1389.                   Md_binary_difference_Integer_Integer,2
  1390.                   );
  1391. #endif
  1392.  
  1393.   (void) make_module_function(stacktop,"-",Fn_nary_difference,-1);
  1394.  
  1395.   generic_binary_times 
  1396.     = make_wrapped_module_generic(stacktop,"binary-times",2,Gf_binary_times);
  1397.   add_root(&generic_binary_times);
  1398.   (void) make_module_function(stacktop,"generic_binary_times,Number,Number",
  1399.                   Md_binary_times_Object_Object,2
  1400.                   );
  1401.  
  1402. #ifndef WITH_BIGNUMS
  1403.   (void) make_module_function(stacktop,"generic_binary_times,Integer,Integer",
  1404.                   Md_binary_times_Integer_Integer,2
  1405.                   );
  1406. #endif
  1407.  
  1408.   (void) make_module_function(stacktop,"*",Fn_nary_times,-1);
  1409.  
  1410.   generic_binary_divide 
  1411.     = make_wrapped_module_generic(stacktop,"binary-divide",2,Gf_binary_divide);
  1412.   add_root(&generic_binary_divide);
  1413.   (void) make_module_function(stacktop,"generic_binary_divide,Number,Number",
  1414.                   Md_binary_divide_Object_Object,2
  1415.                   );
  1416. /*
  1417.   (void) make_module_function(stacktop,generic_binary_divide,
  1418.                   Md_binary_divide_Integer_Integer,
  1419.                   Integer,Integer);
  1420. */
  1421.   (void) make_module_function(stacktop,"/",Fn_nary_divide,-1);
  1422.  
  1423.   generic_binary_gcd 
  1424.     = make_wrapped_module_generic(stacktop,"binary-gcd",2,Gf_binary_gcd);
  1425.   add_root(&generic_binary_gcd);
  1426.   (void) make_module_function(stacktop,"generic_binary_gcd,Integer,Integer",
  1427.                   Md_binary_gcd_Integer_Integer,2
  1428.                   );
  1429.   (void) make_module_function(stacktop,"gcd",Fn_gcd,-1);
  1430.   generic_binary_lcm 
  1431.     = make_wrapped_module_generic(stacktop,"binary-lcm",2,Gf_binary_lcm);
  1432.   add_root(&generic_binary_lcm);
  1433.   (void) make_module_function(stacktop,"generic_binary_lcm,Integer,Integer",
  1434.                   Md_binary_lcm_Integer_Integer,2
  1435.                   );
  1436.   (void) make_module_function(stacktop,"lcm",Fn_lcm,-1);
  1437.  
  1438.   generic_eqn = make_wrapped_module_generic(stacktop,"=",2,Gf_eqn);
  1439.   add_root(&generic_eqn);
  1440.   (void) make_module_function(stacktop,"generic_eqn,Number,Number",
  1441.                   Md_eqn_Number_Number,2
  1442.                   );
  1443.   (void) make_module_function(stacktop,"generic_equal,Number,Number",
  1444.                   Gf_eqn,2
  1445.                   );
  1446.  
  1447.   generic_zerop = make_wrapped_module_generic(stacktop,"zerop",1,Gf_zerop);
  1448.   add_root(&generic_zerop);
  1449.   (void) make_module_function(stacktop,"generic_zerop,Number", Md_zerop_Number,1);
  1450.  
  1451.   generic_abs = make_wrapped_module_generic(stacktop,"abs",1,Gf_abs);
  1452.   add_root(&generic_abs);
  1453.   (void) make_module_function(stacktop,"generic_abs,Number",Md_abs_Number,1);
  1454.  
  1455.   /* Maths constants... */
  1456.  
  1457.   (void) make_module_entry(stacktop, "pi",allocate_float(stacktop,(double) 3.141592653589794));
  1458.   (void) make_module_entry(stacktop, "e",allocate_float(stacktop,(double) 2.718281828459046));
  1459.  
  1460.   (void) make_module_function(stacktop,"single-precision-integer-p",Fn_fixnump,1);
  1461.   (void) make_module_function(stacktop,"oddp",Fn_oddp,1);
  1462.   (void) make_module_function(stacktop,"evenp",Fn_evenp,1);
  1463.   (void) make_module_function(stacktop,"floatp",Fn_floatp,1);
  1464.   (void) make_module_function(stacktop,"floor",Fn_floor,1);
  1465.   (void) make_module_function(stacktop,"ceiling",Fn_ceiling,1);
  1466.   (void) make_module_function(stacktop,"sin",Fn_sin,1);
  1467.   (void) make_module_function(stacktop,"cos",Fn_cos,1);
  1468.   (void) make_module_function(stacktop,"exp",Fn_exp,1);
  1469.   (void) make_module_function(stacktop,"acos",Fn_acos,1);
  1470.   (void) make_module_function(stacktop,"asin",Fn_asin,1);
  1471.   (void) make_module_function(stacktop,"atan",Fn_atan,1);
  1472.   (void) make_module_function(stacktop,"atan2",Fn_atan2,2);
  1473.   (void) make_module_function(stacktop,"tan",Fn_tan,1);
  1474.   (void) make_module_function(stacktop,"acosh",Fn_acosh,1);
  1475.   (void) make_module_function(stacktop,"asinh",Fn_asinh,1);
  1476.   (void) make_module_function(stacktop,"atanh",Fn_atanh,1);
  1477.   (void) make_module_function(stacktop,"cosh",Fn_cosh,1);
  1478.   (void) make_module_function(stacktop,"sinh",Fn_sinh,1);
  1479.   (void) make_module_function(stacktop,"tanh",Fn_tanh,1);
  1480.   (void) make_module_function(stacktop,"log",Fn_log,-1);
  1481.  
  1482.   (void) make_module_function(stacktop,"quotient",Fn_quotient,2);
  1483.   (void) make_module_function(stacktop,"remainder",Fn_remainder,2);
  1484.   (void) make_module_function(stacktop,"modulo",Fn_remainder,2);
  1485.  
  1486.   generic_binary_lt 
  1487.     = make_wrapped_module_generic(stacktop,"binary-lt",2,Gf_binary_lt);
  1488.     add_root(&generic_binary_lt);
  1489.   (void) make_module_function(stacktop,"generic_binary_lt,Number,Number",
  1490.                   Md_binary_lt_Number,2
  1491.                   );
  1492.   (void) make_module_function(stacktop,"generic_binary_lt,Integer,Integer",
  1493.                   Md_binary_lt_Integer,2
  1494.                   );
  1495.   (void) make_module_function(stacktop,"<",Fn_lt,-1);
  1496.  
  1497.   generic_binary_gt 
  1498.     = make_wrapped_module_generic(stacktop,"binary-gt",2,Gf_binary_gt);
  1499.   add_root(&generic_binary_gt);
  1500.   (void) make_module_function(stacktop,"generic_binary_gt,Number,Number",
  1501.                   Md_binary_gt_Number,2
  1502.                   );
  1503.   (void) make_module_function(stacktop,"generic_binary_gt,Integer,Integer",
  1504.                   Md_binary_gt_Integer,2
  1505.                   );
  1506.   (void) make_module_function(stacktop,">",Fn_gt,-1);
  1507.  
  1508.   (void) make_module_function(stacktop,"<=",Fn_lt_or_equal,-1);
  1509.   (void) make_module_function(stacktop,">=",Fn_gt_or_equal,-1);
  1510.  
  1511.   (void) make_module_function(stacktop,"max",Fn_max,-1);
  1512.   (void) make_module_function(stacktop,"min",Fn_min,-1);
  1513.  
  1514.   (void) make_module_function(stacktop,"truncate",Fn_truncate,1);
  1515.   (void) make_module_function(stacktop,"round",Fn_round,1);
  1516.  
  1517.   (void) make_module_function(stacktop,"real-part",Fn_Real_Part,1);
  1518.   (void) make_module_function(stacktop,"imaginary-part",Fn_Imaginary_Part,1);
  1519.   (void) make_module_function(stacktop,"make-rectangular",Fn_Make_Rectangular,2);
  1520.  
  1521.   (void) make_module_function(stacktop,"numerator",Fn_Numerator,1);
  1522.   (void) make_module_function(stacktop,"denominator",Fn_Denominator,1);
  1523.   
  1524.   /* PAB added */
  1525.   (void) make_module_function(stacktop,"sqrt",Fn_sqrt,1);
  1526.   
  1527.   close_module();
  1528.  
  1529. }
  1530.